home *** CD-ROM | disk | FTP | other *** search
/ United Public Domain Gold 2 / United Public Domain Gold 2.iso / music_utilities / pt030.dms / pt030.adf / Scheme / repl.scm < prev    next >
Text File  |  1987-06-15  |  3KB  |  109 lines
  1. ;;; repl.scm
  2.  
  3. (define (make-id-cont)
  4.   (call/cc
  5.     (lambda (return)
  6.       (call/cc
  7.     (lambda (later) (return later))) )))
  8.  
  9. (define (make-error-handler interrupt-mask affected-interrupts restart-cont)
  10.   (define (error-handler packet)
  11.     (display "Yeeow!  ")
  12.     (display (cadr packet))
  13.     (newline)
  14.     (display (car packet))
  15.     (newline)
  16.     (display "Interrupt flags/mask: ")
  17.     (display (number->string (current-interrupt-flags) '(int (radix x e))))
  18.     (display #\/)
  19.     (display (number->string (current-interrupt-mask) '(int (radix x e))))
  20.     (newline)
  21.     (newline)
  22.     (collect-garbage)
  23.     (restart-cont "hello-again") )
  24.   (with-interrupt-mask interrupt-mask affected-interrupts
  25.     (lambda ()
  26.       (call/cc
  27.     (lambda (return)
  28.       (error-handler
  29.         (call/cc
  30.           (lambda (later) (return later)) )))))) )
  31.  
  32.  
  33.  
  34. (define (read-until stop-char omit?)
  35.   (define (get-next input-list)
  36.     (let ((c (read-char)))
  37.       (cond ((eof-object? c)
  38.          (finish input-list))
  39.         ((eq? c stop-char)
  40.          (finish (if omit? input-list (cons c input-list))))
  41.         (else
  42.          (get-next (cons c input-list))))))
  43.   (define (finish lst)
  44.     (reverse lst))
  45.   (get-next '()))
  46.  
  47.  
  48.  
  49. (define (check-system-call cmdchar obj)
  50.   (if (symbol? obj)
  51.       (let ((chars (string->list (symbol->string obj))))
  52.     (if (and (not (null? chars)) (eq? cmdchar (car chars)))
  53.         (let ((cmd (list->string (append (cdr chars) (read-until #\newline #t)))))
  54.           (call-system cmd)
  55.           #t)))))
  56.  
  57.  
  58.  
  59. (define *LEVEL* 0)
  60.  
  61. (define (repl repl-read repl-eval repl-print)
  62.   (define cmdchar #\~)
  63.   (define internal-repl
  64.     (let ((*LAST-IN*  'undefined)
  65.       (*LAST-OUT* 'undefined))
  66.       (let ((internal-env (the-environment)))
  67.     (lambda ()
  68.       (newline)
  69.       (display *LEVEL*)
  70.       (display "=> ")
  71.       (let ((obj (repl-read)))
  72.         (cond ((eof-object? obj)
  73.            'done)
  74.           (else
  75.            (cond ((check-system-call cmdchar obj)
  76.               (newline))
  77.              (else
  78.               (let ((result (repl-eval obj internal-env)))
  79.                 (eval `(set! *LAST-IN*  ',obj)    internal-env)
  80.                 (eval `(set! *LAST-OUT* ',result) internal-env)
  81.                 (repl-print result)
  82.                 (newline))))
  83.            (internal-repl))))))))
  84.   (define protected-repl
  85.     (call/cc
  86.       (lambda (return)
  87.     (error-context
  88.       (make-error-handler
  89.         #x0002
  90.         #xFFFF
  91.         (with-interrupt-mask #x0002 #xFFFF
  92.           (lambda ()
  93.         (call/cc
  94.           (lambda (return)
  95.             (call/cc (lambda (later) (return later)))
  96.             (protected-repl "hello-again")))) ))
  97.       (lambda ()
  98.         (call/cc (lambda (later) (return later)))
  99.         (internal-repl))))))
  100.   (if (procedure? protected-repl)
  101.       (begin (set! *LEVEL* (+ *LEVEL* 1))
  102.          (protected-repl "first-time"))
  103.       (set! *LEVEL* (- *LEVEL* 1))))
  104.  
  105.  
  106.  
  107. ;;; EOF repl.scm
  108.  
  109.